require(methods)

###**********************************************************

setClass("SweaveSyntaxSlots",
         representation(doc = "character",
                        code = "character",
                        coderef = "character",
                        options = "character",
                        docexpr = "character",
                        extension = "character",
                        syntaxname = "character",
                        bof = "character",
                        eof = "character"))


setClass("SweaveSyntax",
         representation(name = "character",
                        read = "SweaveSyntaxSlots",
                        write = "SweaveSyntaxSlots"))

SweaveSyntaxNoweb <-
    new("SweaveSyntax",
        name = "noweb",
        read = new("SweaveSyntaxSlots",
                 doc = c("^@", ""),
                 code = c("^<<(.*)>>=.*", ""),
                 coderef = "^<<(.*)>>.*",
                 options = "\\\\SweaveOpts{([^}]*)}",
                 docexpr = "\\\\Sexpr{([^}]*)}",
                 extension = "\\.[rsRS]?nw$",
                 syntaxname = "\\\\SweaveSyntax{([^}]*)}"),
        write = new("SweaveSyntaxSlots",
                    doc = c("@", "", ""),
                    code = c("<<", ">>=", ""),
                    coderef = c("<<",">>"),
                    options = c("\\\\SweaveOpts{", "}"),
                    docexpr = c("\\\\Sexpr{", "}"),
                    extension = ".Snw",
                    syntaxname = "\\\\SweaveSyntax{SweaveSyntaxNoweb}"))


SweaveSyntaxLatex <- SweaveSyntaxNoweb
SweaveSyntaxLatex@name <- "LaTeX"
SweaveSyntaxLatex@read@doc <-  "^[[:space:]]*\\\\end{Scode}"
SweaveSyntaxLatex@read@code <- "^[[:space:]]*\\\\begin{Scode}{?([^}]*)}?.*"
SweaveSyntaxLatex@read@coderef <- "^[[:space:]]*\\\\Scoderef{([^}]*)}.*"
SweaveSyntaxLatex@read@extension <- "\\.[rsRS]tex$"

SweaveSyntaxLatex@write@doc <-  c("", "", "")
SweaveSyntaxLatex@write@code <- c("\\\\begin{Scode}{", "}", "\\\\end{Scode}")
SweaveSyntaxLatex@write@coderef <- c("\\\\Scoderef{", "}")
SweaveSyntaxLatex@write@syntaxname <- "\\\\SweaveSyntax{SweaveSyntaxLatex}"
SweaveSyntaxLatex@write@extension <- ".Stex"


###**********************************************************

SweaveGetSyntax <- function(file){

    synt <- apropos("SweaveSyntax", mode="list")
    for(sname in synt){
        s <- get(sname, mode="list")
        if(class(s) != "SweaveSyntax") next
        if(any(grep(s@read@extension, file))) return(s)
    }
    return(SweaveSyntaxNoweb)
}

###**********************************************************

setClass("SweaveOptions",
         representation(
                        name="character",
                        engine="character",
                        eval="logical",
                        
                        include="logical",
                        prefix="logical",
                        prefix.string="character",
                        split="logical",
                        
                        echo="logical",
                        print="logical",
                        results="character",
                        strip.white="logical",
                        term="logical",
                        
                        eps="logical",
                        fig="logical",
                        height="numeric",
                        pdf="logical",
                        width="numeric",
                        
                        other="logical"),
         prototype(
                   engine="S",
                   eval=TRUE,
                   include=TRUE,
                   prefix=TRUE,
                   split=FALSE,
                   
                   echo=TRUE,
                   print=FALSE,
                   results="verbatim",
                   strip.white=TRUE,
                   term=TRUE,
                        
                   fig=FALSE,
                   eps=TRUE,
                   pdf=TRUE,
                   height=6,
                   width=6)
         )


setMethod("show", "SweaveOptions",
function(object)
{
    if(length(object@name)>0)
        cat("   # name:", object@name, "\n")
    cat("   #")
    if(object@echo) cat(" echo")
    if(object@eval) cat(" eval")
    if(object@eval){
        if(object@print) cat(" print")
        if(object@term) cat(" term")
        cat("", object@results)
    }
    cat("\n")
    if(object@eval & object@fig){
        cat("   # fig:")
        if(object@eps) cat(" eps")
        if(object@pdf) cat(" pdf")
        cat(" ", object@width, "x", object@height, sep="")
        cat("\n")
    }
})

        



###**********************************************************
         
setClass("Chunk",
         representation(text="character",
                        name="character"))

setClass("DynDoc",
         representation(chunks="list",
                        file="character",
                        call="call"))

setClass("SweaveDocChunk", contains="Chunk")

setClass("SweaveCodeChunk",
         representation(options="SweaveOptions",
                        optstring="character"),
         contains="Chunk")


                 
.printChunkText <- function(text){
    if(length(text)>6){
        cat(paste("  ", text[1:3]),sep="\n")
        cat("   ...\n")
        cat(paste("  ", text[length(text)-2:0]), sep="\n")
    }
    else
        cat(paste("  ", text), sep="\n")
}

setMethod("show", "Chunk", function(object) .printChunkText(object@text))
setMethod("show", "SweaveCodeChunk",
function(object){
    print(object@options)
    .printChunkText(object@text)
})

###**********************************************************

setClass("Sweave",
         representation(syntax="SweaveSyntax"),
         contains="DynDoc")

setMethod("show", "Sweave",
function(object){
    cat("\nCall:\n", deparse(object@call), "\n\n", sep = "")
    cat("File:", object@file, "\n")
    cat("Syntax:", object@syntax@name, "\n\n")
    cat("Class and number of chunks:")
    print(table(sapply(object@chunks, class)))
})      
         
         
      

###**********************************************************

setGeneric("insertSweaveOptions",
           function(text, options)
           standardGeneric("insertSweaveOptions"))

setMethod("insertSweaveOptions",
          signature(text="character", options="missing"),
function(text, options)
{
    insertSweaveOptions(text, "SweaveOptions")
})
    
setMethod("insertSweaveOptions",
          signature(text="character", options="character"),
function(text, options)
{
    options = new(options)
    insertSweaveOptions(text, options)
})
    
setMethod("insertSweaveOptions",
          signature(text="character", options="SweaveOptions"),
function(text, options)
{
    x <- sub("^[[:space:]]*\(.*\)", "\\1", text)
    x <- sub("\(.*[^[:space:]]\)[[:space:]]*$", "\\1", x)
    x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
    x <- strsplit(x, "[[:space:]]*=[[:space:]]*")

    ## only the first option may have no name: the chunk label
    if(length(x)>0){
        if(length(x[[1]])==1){
            x[[1]] <- c("name", x[[1]])
        }
    }
    else
        return(options)

    if(any(sapply(x, length)!=2))
        stop(paste("Parse error or empty option in\n", text))

    
    for(k in seq(length=length(x))){
        sn = x[[k]][1]
        if(x[[k]][1] %in% slotNames(options)){
            sc = class(slot(options, sn))
            if(sc == "logical"){
                val =  as(toupper(x[[k]][2]), "logical")
            }
            else
                val = as(x[[k]][2], sc)

            slot(options, sn) = val
        }
        else{
            val =  as(toupper(x[[k]][2]), "logical")
            options@other[sn] = val
        }
        
        if(is.na(val))
            stop(paste("invalid value for", sn, ":", x[[k]][2]))
    }

    options@results <- match.arg(options@results,
                                 c("verbatim", "tex", "hide"))
    
    options
})
    

setAs("character", "SweaveOptions",
      function(from, to) insertSweaveOptions(from, to))


setClass("SweaveDriver",
         representation(options="SweaveOptions",
                        runcode="function",
                        writedoc="function",
                        setup="function",
                        finish="function"))
                       
###**********************************************************


read.Sweave <- function(file, syntax=getOption("SweaveSyntax"),
                        options=new("SweaveOptions"))
{
    if(is.null(syntax))
        syntax <- SweaveGetSyntax(file)
    if(is.character(syntax))
        syntax <- get(syntax, mode="list")

    z <- new("Sweave", syntax=syntax, file=file)
    z@call <- match.call()

    text <- readLines(file)

    MAXHEAD = 1000
    for(m in 1:MAXHEAD){
        MATCH=FALSE
        for(n in seq(length=length(syntax@read@bof))){
            if(any(grep(syntax@read@bof[n], text[1]))){
                text = text[-1]
                MATCH=TRUE
            }
        }
        if(!MATCH) break
    }
    if(m==MAXHEAD) stop("Problems while parsing begin of file")
    for(m in 1:MAXHEAD){
        MATCH=FALSE
        for(n in seq(length=length(syntax@read@eof))){
            if(any(grep(syntax@read@eof[n], text[length(text)]))){
                text = text[-length(text)]
                MATCH=TRUE
            }
        }
        if(!MATCH) break
    }
    if(m==MAXHEAD) stop("Problems while parsing end of file")
    
    mode <- "doc"
    chunk <- NULL
    optstring <- ""

    for(line in text){
        if((nchar(z@syntax@read@doc[2]) > 0) &&
           any(grep(z@syntax@read@doc[2], line))) next
        if((nchar(z@syntax@read@code[2]) > 0) &&
           any(grep(z@syntax@read@code[2], line))) next

        
        
        if(any(grep(z@syntax@read@doc[1], line)) ||
           any(grep(z@syntax@read@code[1], line)))
        {
            if(!is.null(chunk)){
                if(mode=="doc"){
                    z@chunks[[length(z@chunks)+1]] <-
                        new("SweaveDocChunk", text=chunk)
                }
                else{
                    z@chunks[[length(z@chunks)+1]] <-
                        new("SweaveCodeChunk", text=chunk,
                            optstring=optstring)
                }
            }
            chunk <- NULL
            mode <- "doc"
            
            if(any(grep(z@syntax@read@code[1], line))){
                optstring <- sub(z@syntax@read@code[1], "\\1", line)
                mode <- "code"
            }
        }
        else{
            if(mode=="doc" && any(grep(z@syntax@read@syntaxname, line))){
                sname <- sub(z@syntax@read@syntaxname, "\\1", line)
                z@syntax <- get(sname, mode = "list")
            }
            if(is.null(chunk))
                chunk <- line
            else
                chunk <- c(chunk, line)
        }
    }
    if(!is.null(chunk)){
        if(mode=="doc"){
            z@chunks[[length(z@chunks)+1]] <-
                new("SweaveDocChunk", text=chunk)
        }
        else{
            z@chunks[[length(z@chunks)+1]] <-
                new("SweaveCodeChunk", text=chunk, optstring=optstring)
        }
    }
    z <- parseSweaveOptions(z, options)
    z
}


parseSweaveOptions <- function(object, options)
{
    options = as(options, "SweaveOptions")

    for(k in seq(length = length(object@chunks))){

        chunk = object@chunks[[k]]
        
        if(is(chunk, "SweaveDocChunk")){
            pos <- grep(object@syntax@read@options, chunk@text)
            for(p in pos)
            {
                opts <- sub(paste(".*", object@syntax@read@options,
                                  ".*", sep=""),
                            "\\1", chunk@text[p])
                options <- insertSweaveOptions(opts, options)
            }
        }
        else{
            object@chunks[[k]]@options <-
                insertSweaveOptions(chunk@optstring, options)
        }
    }
    object
}

###**********************************************************

setGeneric("writeSweaveFile",
           function(object, file="", append=FALSE, syntax=NULL)
           standardGeneric("writeSweaveFile"))

setMethod("writeSweaveFile",
          signature(object="Sweave"),
function(object, file="", append=FALSE, syntax=NULL)
{
    if(!is.null(syntax)){
        syntax = as(syntax, "SweaveSyntax")
        object = SweaveSyntConv(object, syntax)
    }

    syntax = object@syntax

    cat(syntax@write@bof, file=file, append=append)
    lapply(object@chunks, writeSweaveFile,
           file=file, append=TRUE, syntax=syntax)
    cat(syntax@write@eof, file=file, append=TRUE)
    invisible(object)
})    

setMethod("writeSweaveFile",
          signature(object="SweaveDocChunk"),
function(object, file="", append=FALSE, syntax=NULL)
{
    cat(syntax@write@doc[1], syntax@write@doc[2],
        "\n", sep="", file=file, append=append)
    cat(paste(object@text, collapse="\n"), file=file, append=TRUE)
    
    if(length(syntax@write@doc[3]>0))
        cat("\n", syntax@write@doc[3], sep="", file=file, append=TRUE)
    
    cat("\n",  file=file, append=TRUE)
})

setMethod("writeSweaveFile",
          signature(object="SweaveCodeChunk"),
function(object, file="", append=FALSE, syntax=NULL)
{
    cat(syntax@write@code[1], object@optstring, syntax@write@code[2],
        "\n", sep="", file=file, append=append)
    cat(paste(object@text, collapse="\n"), file=file, append=TRUE)
    
    if(length(syntax@write@code[3]>0))
        cat("\n", syntax@write@code[3], sep="", file=file, append=TRUE)

    cat("\n",  file=file, append=TRUE)
})


###**********************************************************

setGeneric("SweaveSyntConv",
           function(object, syntax, oldsyntax)
           standardGeneric("SweaveSyntConv"))

setMethod("SweaveSyntConv",
          signature(object="Sweave",
                    syntax="SweaveSyntax"),
function(object, syntax, oldsyntax){

    oldsyntax = object@syntax
    object@chunks = lapply(object@chunks, SweaveSyntConv,
                           syntax=syntax, oldsyntax=oldsyntax)

    object@syntax = syntax
    object@file = ""
    object@call = match.call()
    object
})

setMethod("SweaveSyntConv",
          signature(object="SweaveCodeChunk",
                    syntax="SweaveSyntax",
                    oldsyntax="SweaveSyntax"),
function(object, syntax, oldsyntax){

    object@text <- .syntaxReplacements(object@text,
                                       oldsyntax@read,
                                       syntax@write,
                                       c("options", "coderef"))
    object
})          


setMethod("SweaveSyntConv",
          signature(object="SweaveDocChunk",
                    syntax="SweaveSyntax",
                    oldsyntax="SweaveSyntax"),
function(object, syntax, oldsyntax){

    object@text <- .syntaxReplacements(object@text,
                                       oldsyntax@read,
                                       syntax@write,
                                       c("options", "docexpr"))
    object
})

.syntaxReplacements <- function(text, readsyntax, writesyntax, what)
{
    for(x in what){
        text <- gsub(slot(readsyntax, x),
                     paste(slot(writesyntax, x)[1],
                           "\\1", slot(writesyntax, x)[2], sep=""),
                     text)
    }
    text
}
    

    
###**********************************************************

